--{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}

import Math
import Vector2D
import Color
import RenderEngine
import StreamEngine
import Projectable

import Data.VectorSpace hiding (Scalar)
import qualified Data.Stream as S
import Data.Stream ((<:>))

import Control.Applicative
import Data.Maybe
import Data.Monoid
import Data.List

import Debug.Trace

-------------------------------------------------------------------------------

data GameSample = GameSample { ballPos :: ![Vector2]
                             , paddlePos :: !Vector2
                             , gameLost  :: !Incident
                             , gameExit :: !Incident
                             }
                  deriving Show

type Game = Signal GameSample

--withBallPos :: Vector2 -> GameSample -> GameSample
--withBallPos v g = g { ballPos = v }

withPaddlePos :: Vector2 -> GameSample -> GameSample
withPaddlePos v g = g { paddlePos = v }

withGameLost :: Incident -> GameSample -> GameSample
withGameLost v g = g { gameLost = v }

withGameExit :: Incident -> GameSample -> GameSample
withGameExit v g = g { gameExit = v }

{-
withPicture :: Picture -> GameSample -> GameSample
withPicture v g = g { picture = v }
-}

-------------------------------------------------------------------------------

wallLeft   :: Scalar 
wallRight  :: Scalar 
wallBottom :: Scalar 
wallTop    :: Scalar 
wallSize   :: Scalar 
wallHeight :: Scalar 
wallWidth  :: Scalar 
ballRadius :: Scalar 

initBallSpeed :: Scalar 
initBallPos   :: Vector2 
initPaddlePos :: Vector2 

paddleWidth :: Scalar
paddleHeight :: Scalar

wallLeft   = worldMinX+10
wallRight  = worldMaxX-10
wallBottom = worldMinY+10
wallTop    = worldMaxY-10
wallSize   = 5
wallHeight = wallTop - wallBottom
wallWidth  = wallRight - wallLeft

ballRadius = 10

initBallSpeed = -200
initBallPos   = vector2 0 0
initPaddlePos = vector2 0 (wallBottom+50)

paddleWidth = 100
paddleHeight = 10

-------------------------------------------------------------------------------

isColliding :: Ordering -> Scalar -> Scalar -> Scalar -> Bool
isColliding ordering wall pos vel = 
  pos `compare` wall == ordering && 
  vel `compare` 0    == ordering

-------------------------------------------------------------------------------

gameExits :: Sensors -> Trigger
gameExits ss = eitherT (keyDowns (SpecialKey ESC) ss) $ 
                 bothT (rightButtonDowns ss) (leftButtonDowns ss)

-------------------------------------------------------------------------------

walls :: Picture
walls = mconcat [leftWall, rightWall, topWall, bottomWall]
    
leftWall :: Picture
leftWall = solidPolygonAt (vector2 wallLeft 0) (rgb 0 0 1) $
           rectPath wallSize wallHeight

rightWall :: Picture
rightWall =  solidPolygonAt (vector2 wallRight 0) (rgb 0 0 1) $
             rectPath wallSize wallHeight

topWall :: Picture
topWall =  solidPolygonAt (vector2 0 wallTop) (rgb 0 0 1) $
           rectPath wallWidth wallSize
              
bottomWall :: Picture
bottomWall = solidPolygonAt (vector2 0 wallBottom) (rgb 1 0 0) $
             rectPath wallWidth wallSize

-------------------------------------------------------------------------------

render :: GameSample -> Picture
render gs = paddle `over` balls `over` walls
  where
    paddle = solidPolygonAt (paddlePos gs) (rgb 1 0 1) $
             rectPath paddleWidth paddleHeight

    balls = mconcat $ ballAt <$> ballPos gs

    ballAt pos = solidPolygonAt pos (rgb 1 1 0) $ 
                 circlePath ballRadius 36


-------------------------------------------------------------------------------

paddlePositions :: Sensors -> Signal Vector2
paddlePositions ss = S.zipWith vector2 paddlePosX paddlePosY
  where
    mp              = mousePositions ss
    dt              = tickDurations ss
    paddlePosX      = integral (projectX initPaddlePos) paddleVelX dt
    paddlePosY      = pure (projectY initPaddlePos)
    paddleVelX      = (projectX <$> mp) ^-^ paddlePosX

ballWallHits :: (Signal Position2, Signal Velocity2) -> (Trigger,Trigger)
ballWallHits (ballPos',ballVel') = (hitsX,hitsY)
  where
    ballVelX        = projectX <$> ballVel'
    ballVelY        = projectY <$> ballVel'
    ballPosX        = projectX <$> ballPos'
    ballPosY        = projectY <$> ballPos'
    wallOffset      = wallSize + ballRadius
    hitsX           = rising (ballColLeft ~||~ ballColRight)
    hitsY           = rising (ballColTop  ~||~ ballColBottom)
    ballColLeft     = isColliding LT (wallLeft+wallOffset)   
                      <$> ballPosX <*> ballVelX
    ballColRight    = isColliding GT (wallRight-wallOffset)  
                      <$> ballPosX <*> ballVelX 
    ballColBottom   = isColliding LT (wallBottom+wallOffset) 
                      <$> ballPosY <*> ballVelY 
    ballColTop      = isColliding GT (wallTop-wallOffset)    
                      <$> ballPosY <*> ballVelY 

{-
ballPaddleHits :: (Signal Position2, Signal Velocity2) -> Signal Position2 -> 
                      (Event Weight,Trigger,Trigger)
ballPaddleHits (ballPos',ballVel') paddlePos' = (hitsX,hitsY,losts)
  where
    ballVelY        = projectY <$> ballVel'
    ballPosX        = projectX <$> ballPos'
    ballPosY        = projectY <$> ballPos'
    paddlePosX      = projectX <$> paddlePos'
    paddlePosY      = projectY <$> paddlePos'
    paddleBottom    = paddlePosY ^+^ pure (paddleHeight/2 + ballRadius)
    paddleLeft      = paddlePosX ^-^ pure (paddleWidth/2)
    paddleRight     = paddlePosX ^+^ pure (paddleWidth/2)
    hitsY           = colliding LT <$> paddleBottom <*> ballPosY <*> ballVelY
    relPosX         = (ballPosX ^-^ paddlePosX) ^/ pure (paddleWidth/2)

    ballColPaddleX  = ballPosX ~>~ paddleLeft ~&&~ ballPosX ~<~ paddleRight
    ballColPaddleY  = ballPosY ~>~ paddleBottom
    ballColPaddle   = ballColPaddleX ~&&~ ballColPaddleY

    hitsX           = boolToMaybe 0 <$> ballColPaddleX --boolToMaybe <$> relPosX <*> (isBetween (-0.5) 0.5 <$> relPosX)
    hits            = hitsY --`bothT` eventToTrigger hitsX
--    hits            = boolToIncident `mapS` ballColPaddle --eventToTrigger hitsX
    losts           = boolToIncident <$> ((not <$> maybeToBool <$> hits) 
                       ~&&~ (ballPosY ^+^ pure ballRadius) ~<~ paddleBottom)
-}

ballPaddleHits :: (Signal Position2, Signal Velocity2) -> Signal Position2 -> 
                      (Event Weight,Trigger)
ballPaddleHits (ballPos',ballVel') paddlePos' = 
  (rising hits `tag_` relPosX,losts)
  where
    ballVelY        = projectY <$> ballVel'
    ballPosX        = projectX <$> ballPos'
    ballPosY        = projectY <$> ballPos'
    paddlePosX      = projectX <$> paddlePos'
    paddlePosY      = projectY <$> paddlePos'
    paddleBottom    = paddlePosY ^+^ pure (paddleHeight/2 + ballRadius)
    paddleLeft      = paddlePosX ^-^ pure (paddleWidth/2)
    paddleRight     = paddlePosX ^+^ pure (paddleWidth/2)
    relPosX         = (ballPosX ^-^ paddlePosX) ^* pure (2/paddleWidth)
    hitsY           = isColliding LT <$> paddleBottom <*> ballPosY <*> ballVelY
    hitsX           = isBetween (-0.5) 0.5 <$> relPosX
    hits            = hitsX ~&&~ hitsY 
    losts           = rising $ (not <$> hits) ~&&~ 
                             ((ballPosY ^+^ pure ballRadius) ~<~ paddleBottom)

ballKinematics :: Position2 -> Speed -> Sensors -> Trigger -> Trigger -> 
                  (Signal Position2,Signal Velocity2)
ballKinematics initPos initSpeed ss hitsX hitsY = (pos,vel)
  where
    dt              = tickDurations ss
    ballPosX        = integral (projectX initPos) ballVelX dt
    ballPosY        = integral (projectY initPos) ballVelY dt
    ballVelX        = S.scan' bounce initSpeed hitsX
    ballVelY        = S.scan' bounce initSpeed hitsY
    pos             = S.zipWith vector2 ballPosX ballPosY
    vel             = S.zipWith vector2 ballVelX ballVelY
    bounce a hit    = maybe a (const $ negate a) hit

bouncingBall :: Position2 -> Speed -> Signal Position2 -> Sensors -> 
                (Signal Position2, Trigger)
bouncingBall initPos initSpeed paddlePos' ss = (fst ballKine,losts)
  where
    ballKine              = ballKinematics initPos initSpeed ss hitsX hitsY
    (wallHitsX,wallHitsY) = ballWallHits ballKine
    (paddleHits,losts)    = ballPaddleHits ballKine paddlePos'
    hitsX                 = wallHitsX
    hitsY                 = wallHitsY `mergeT` trigger paddleHits
    
paddleDemo :: Sensors -> Game
paddleDemo ss = 
  GameSample <$> section [ballPos1,ballPos2]
             <*> paddlePos' 
             <*> losts1 `mergeT` losts2
             <*> gameExits ss
  where
    paddlePos'      = paddlePositions ss
    (ballPos1, losts1) = bouncingBall initBallPos initBallSpeed paddlePos' ss
    (ballPos2, losts2) = bouncingBall initBallPos (-initBallSpeed) paddlePos' ss

-------------------------------------------------------------------------------

type SS = SensorsSample

sswitch :: forall a. Signal a -> Sensors -> 
           Event (a -> Sensors -> Signal a) ->
           Signal a
sswitch as ss es = fst <$> switch ass eas
  where
    ass = S.zip as ss
    eas = mapE aux es
      where
        aux :: (a -> Sensors -> Signal a) -> 
               (a,SS) -> Signal (a,SS) -> Signal (a,SS)
        aux f asp sasp = S.zip (f (fst asp) ss') ss'
          where
            ss' = snd <$> sasp

-------------------------------------------------------------------------------

gameLoop :: Sensors -> Game
gameLoop ss = sswitch gs ss (maybeGameOver `mergeE` maybeRestart)
  where
    gs = paddleDemo ss
    maybeGameOver = mapT gameOver (gameLost <$> gs)
    maybeRestart  = mapT (const gameLoop) (rightButtonDowns ss)

gameOver :: GameSample -> Sensors -> Game
gameOver g ss = sswitch gs ss maybeRestart
  where 
    gs = (`withGameExit` g) <$> gameExits ss
    maybeRestart = mapT (const gameLoop) (leftButtonDowns ss)

game :: Sensors -> Pictures
game = map render . S.takeWhile (isNothing . gameExit) . gameLoop

-------------------------------------------------------------------------------

main :: IO ()
main = run game

z :: IO ()
z = main
